home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IO Examples / Scrabble / graphics.icl < prev    next >
Encoding:
Modula Implementation  |  1997-05-14  |  11.9 KB  |  349 lines  |  [TEXT/3PRM]
  1. implementation module graphics
  2.  
  3.  
  4. import    StdInt, StdBool, StdReal, StdChar, StdList, StdFunc, StdEnum, StdArray, StdTuple, StdMisc
  5. import    deltaEventIO, deltaPicture, deltaFont, deltaDialog
  6. import    board, language, systemsettings
  7.  
  8.  
  9. ::    Size            :==    (!Int,!Int)
  10.  
  11. grey                :==    RGB 0.5 0.5 0.5
  12. darkgrey            :==    RGB 0.31 0.31 0.31
  13. rbBoardGrey            :== RGB 0.75  0.75  0.75
  14. rbLighterGrey        :== RGB 0.878 0.878 0.878
  15. rbBoardRed3            :== RGB 1.0   0.5   0.5
  16. rbBoardRed2            :== RGB 0.75  0.625 0.625
  17. rbBoardBlue3        :== RGB 0.5   0.5   1.0
  18. rbBoardBlue2        :== RGB 0.625 0.625 0.75
  19. rbSquare            :== RGB 1.0   1.0   0.75 
  20. rbDarkYellow        :== RGB 0.5   0.5   0.0
  21.  
  22. displaywidth        :==    250
  23. displayheight        :==    130
  24. boardwidth            :==    391
  25. boardheight            :==    391
  26. squarewidth            ::    Int
  27. squarewidth            =:    boardwidth/15
  28. squareheight        ::    Int
  29. squareheight        =:    boardheight/15
  30.  
  31. alphabet            :==    "abcdefghijklmnopqrstuvwxyz"
  32.  
  33.  
  34. /*    Mapping 'Amanda-space' to 'Scrabble-space' to 'Pixel-space':
  35.     Amanda-space    : ((-1.0,1.0),(1.0,-1.0))
  36.     Scrabble-space    : ((0.0,0.0), (14.0,14.0))
  37.     Pixel-space        : ((0,0), (width,height))
  38. */
  39.  
  40. abs2rel :: !(!Int,!Int) -> (!Int,!Int)
  41. abs2rel (x,y) = (x/squarewidth,y/squareheight)
  42.  
  43. instance toString ControlState
  44. where
  45.     toString :: !ControlState -> {#Char}
  46.     toString (StringCS s)    = s
  47.     toString _                = abort "toString not applied to (StringCS _).\n"
  48.  
  49. toStringCS :: String -> ControlState
  50. toStringCS s = StringCS s
  51.  
  52.  
  53. /*    The drawing operations.    */
  54.  
  55. boardlook :: !Board !Size !SelectState ControlState -> [DrawFunction]
  56. boardlook (hor,_) size=:(w,h) select cstate
  57. =    [    SetPenColour    rbBoardGrey 
  58.     ,    FillRectangle    ((0,0),size)
  59.     ,    SetPenColour    WhiteColour
  60.     ]
  61.     ++ 
  62.     [    DrawVectorAt (squarewidth*i+1,0) (0,h) \\ i<-is    ]
  63.     ++
  64.     [    DrawVectorAt (0,squareheight*i+1) (w,0) \\ i<-is    ]
  65.     ++
  66.     [    SetPenColour darkgrey : [ DrawVectorAt (squarewidth*i,1) (0,h-1) \\ i<-is ] ]
  67.     ++
  68.     [    DrawVectorAt (1,squareheight*i) (w-1,0) \\ i<-is ]
  69.     ++    map (drawsquare rbBoardBlue2) doubleletterpositions
  70.     ++    map (drawsquare rbBoardBlue3) tripleletterpositions
  71.     ++    map (drawsquare rbBoardRed2)  doublewordpositions
  72.     ++    map (drawsquare rbBoardRed3)  triplewordpositions
  73.     ++    drawcenter
  74.     ++
  75.     [    drawletter l (i,j) \\ i<-[0..14], j<-[0..14], l<-[(hor!!j)!!i] ]
  76.     ++
  77.     (    if (isAble select) (drawfocus True cstate) []    )
  78. where
  79.     is            = [0..15]
  80.     
  81.     drawcenter :: [DrawFunction]
  82.     drawcenter
  83.     =    [drawsquare rbBoardGrey (7,7),SetPenColour grey,FillPolygon (absposition (7.5,7.5),shape)]
  84.     where
  85.         h        = (squarewidth-1)/2
  86.         v        = (squareheight-1)/2
  87.         shape    = [(0,0-v),(h,v),(0-h,v),(0-h,0-v),(h,0-v)]
  88.     //    absposition maps a position in 'Scrabble-space' to a position in 'Pixel-space'.
  89.         absposition :: !(!Real,!Real) -> (!Int,!Int)
  90.         absposition (col,row)
  91.         =    (toInt (col*toReal squarewidth),toInt (row*toReal squareheight))
  92.     
  93.     drawsquare :: !Colour !(!Int,!Int) !Picture -> Picture
  94.     drawsquare colour (col,row) picture
  95.     #    picture    = SetPenColour    colour            picture
  96.         picture    = FillRectangle    ((l,t),(r,b))    picture
  97.     =    picture
  98.     where
  99.         l = col*squarewidth+2
  100.         t = row*squareheight+2
  101.         r = (col+1)*squarewidth
  102.         b = (row+1)*squareheight
  103.     
  104.     isAble :: SelectState -> Bool
  105.     isAble Able = True
  106.     isAble _    = False
  107.  
  108. drawfocus :: !Bool !ControlState -> [DrawFunction]
  109. drawfocus noterase (PairCS (IntCS x) (IntCS y))
  110. =    [    SetPenColour    lefttopcolour
  111.     ,    MovePenTo        (l,b)
  112.     ,    LinePen            (0,0-(squareheight-1))
  113.     ,    LinePen            (squarewidth-1,0)
  114.     ,    SetPenColour    rightbotcolour
  115.     ,    LinePen            (0,squareheight-1)
  116.     ,    LinePen            (0-(squarewidth-1),0)
  117.     ]
  118. where
  119.     (col,row)                        = abs2rel (x,y)
  120.     l                                = col*squarewidth+1
  121.     b                                = (row+1)*squareheight
  122.     (lefttopcolour,rightbotcolour)    = if noterase (darkgrey, WhiteColour)
  123.                                                   (WhiteColour, darkgrey)
  124. drawfocus _ _
  125. =    abort "drawfocus not applied to (PairCS (IntCS _) (IntCS _)).\n"
  126.  
  127.  
  128. drawletter :: !Char !(!Int,!Int) !Picture -> Picture
  129. drawletter l (i,j) picture
  130. |    l==' '        = picture
  131. #   picture        = SetPenColour    rbSquare                                    picture
  132.     picture        = FillRectangle    ((x+2,y+2),(x+squarewidth,y+squareheight))    picture
  133.     picture        = MovePenTo        (x+2,y+squareheight-1)                        picture
  134.     picture        = SetPenColour    WhiteColour                                    picture
  135.     picture        = LinePenTo        (x+2,y+2)                                    picture
  136.     picture        = LinePenTo        (x+squarewidth-1,y+2)                        picture
  137.     picture        = SetPenColour    YellowColour                                picture
  138.     picture        = LinePenTo        (x+squarewidth-1,y+squareheight-1)            picture
  139.     picture        = LinePenTo        (x+2,y+squareheight-1)                        picture
  140.     picture        = MovePenTo        (x+squarewidth/4,y+h-h/3)                    picture
  141.     picture        = SetFont        letterfont                                    picture
  142.     picture        = SetPenColour    BlackColour                                    picture
  143.     picture        = DrawChar        (toUpper l)                                    picture
  144.     picture        = SetFont        smallfont                                    picture
  145.     picture        = SetPenColour    rbDarkYellow                                picture
  146.     picture        = DrawStringAt    (x+squarewidth-2-plen,y+h-3) scoretext        picture
  147. |    otherwise    = picture
  148. where
  149.     x            = i*squarewidth
  150.     y            = j*squareheight
  151.     h            = squareheight
  152.     scoretext    = toString (lettervalue l)
  153.     plen        = FontStringWidth scoretext smallfont
  154.  
  155.  
  156. redrawboard :: !Board !(IOState t) -> IOState t
  157. redrawboard board iostate
  158. =    ChangeDialog scrabbleId [ChangeControlLook 100 (boardlook board (boardwidth,boardheight))] iostate
  159.  
  160. letterboxlook :: ![Char] SelectState ControlState -> [DrawFunction]
  161. letterboxlook letters _ _
  162. =    [    SetPenColour    rbBackground 
  163.     ,    FillRectangle    ((0,0),(squarewidth*4,squareheight*15))
  164.     ]
  165.     ++
  166.     [    drawletter c (0,j) \\ (c,j)<-zip2 leftchars  js    ]
  167.     ++
  168.     [    drawletter c (2,j) \\ (c,j)<-zip2 rightchars js    ]
  169.     ++
  170.     [    SetFont            letterfont
  171.     ,    SetPenColour    BlackColour
  172.     ]
  173.     ++
  174.     [    drawcount c (1,j) \\ (c,j)<-zip2 leftcounts  js    ]
  175.     ++
  176.     [    drawcount c (3,j) \\ (c,j)<-zip2 rightcounts js    ]
  177. where
  178.     js                            = [0..14]
  179.     counts                        = countletters alphabet (sort letters)
  180.     (left,right)                = splitAt 15 counts
  181.     (leftchars, leftcounts)        = unzip left
  182.     (rightchars,rightcounts)    = unzip right
  183.     
  184.     drawcount :: !Int !(!Int,!Int) !Picture -> Picture
  185.     drawcount count (i,j) picture
  186.     =    DrawStringAt (x+squarewidth/4,y+h-h/3) (toString count) picture
  187.     where
  188.         x            = i*squarewidth
  189.         y            = j*squareheight
  190.         h            = squareheight
  191.     
  192.     countletters :: !String ![Char] -> [(Char,Int)]
  193.     countletters chars letters
  194.     |    chars==""
  195.     =    []
  196.     #    c                        = chars.[0]
  197.         (count,letters)            = countletter c letters
  198.     =    [(c,count):countletters (chars%(1,size chars-1)) letters]
  199.     where
  200.         countletter :: !Char ![Char] -> (Int,![Char])
  201.         countletter c all_letters=:[letter:letters]
  202.         |    c<>letter            = (0,all_letters)
  203.         #    (count,letters)        = countletter c letters
  204.         |    otherwise            = (count+1,letters)
  205.         countletter _ _
  206.         =    (0,[])
  207.  
  208. drawletterbox :: ![Char] !(IOState t) -> IOState t
  209. drawletterbox letters iostate
  210. =    ChangeDialog scrabbleId [ChangeControlLook 111 (letterboxlook letters)] iostate
  211.  
  212. drawplayer1letters :: ![Char] !(IOState t) -> IOState t
  213. drawplayer1letters letters iostate
  214. =    ChangeDialog scrabbleId [ChangeControlState 102 (StringCS (toString letters))] iostate
  215.  
  216. drawplayer2letters :: ![Char] !(IOState t) -> IOState t
  217. drawplayer2letters letters iostate
  218. =    ChangeDialog scrabbleId [ChangeControlState 104 (StringCS (toString letters))] iostate
  219.  
  220. playerletterslook :: !Size SelectState !ControlState -> [DrawFunction]
  221. playerletterslook dim _ (StringCS ws)
  222. =    [    SetPenColour    rbBackground
  223.     ,    FillRectangle    ((0,0),dim)
  224.     :
  225.     [    drawletter ws.[i] (i,0) \\ i<-[0..size ws-1] ]
  226.     ]
  227. playerletterslook _ _ _
  228. =    abort "playerletterslook not applied to (StringCS _).\n"
  229.  
  230. drawplayer1score :: !Int !(IOState t) -> IOState t
  231. drawplayer1score s iostate
  232. =    ChangeDialog scrabbleId [ChangeDynamicText 106 (toString s)] iostate
  233.  
  234. drawplayer2score :: !Int !(IOState t) -> IOState t
  235. drawplayer2score s iostate
  236. =    ChangeDialog scrabbleId [ChangeDynamicText 108 (toString s)] iostate
  237.  
  238. drawcommunication :: ![String] !(IOState s) -> IOState s
  239. drawcommunication text iostate
  240. =    ChangeDialog scrabbleId [    ChangeControlState 110 (ListCS (map toStringCS text))
  241.                             ,    ChangeControlLook  110 (displaylook (displaywidth,displayheight))
  242.                             ] iostate
  243.  
  244. displaylook :: !Size SelectState !ControlState -> [DrawFunction]
  245. displaylook size _ (ListCS text)
  246. =    [drawtext (map toString text) size]
  247. where
  248.     drawtext :: ![String] !Size !Picture -> Picture
  249.     drawtext text size=:(w,h) picture
  250.     #    picture = drawdisplay    size        picture
  251.         picture = SetFont        (font 12)    picture
  252.         picture = SetPenColour    RedColour    picture
  253.         picture    = seq [ DrawStringAt (w/20,h*y/10) l \\ (y,l)<-zip2 [2,4..] text ] picture
  254.     =    picture
  255.  
  256. drawprogress :: !Player !Progress !Placing !(IOState t) -> IOState t
  257. drawprogress player progress placing iostate
  258. =    ChangeDialog scrabbleId [ChangeControlLook 110 (progresslook player progress placing (displaywidth,displayheight))] iostate
  259. where
  260.     progresslook :: !Player !Progress !Placing !Size SelectState ControlState -> [DrawFunction]
  261.     progresslook player progress placing size _ _
  262.     =    [progresslook` player progress placing size]
  263.     where
  264.         progresslook` :: !Player !Progress !Placing !Size !Picture -> Picture
  265.         progresslook` player (Letter letter _) placing size=:(w,h) picture
  266.         #    picture            = drawdisplay    size                            picture
  267.             picture            = SetFont        thefont                            picture
  268.             picture            = SetPenColour    grey                            picture
  269.             picture            = DrawStringAt    letterspos alphabet                picture
  270.             picture            = SetPenColour    GreenColour                        picture
  271.             picture            = DrawStringAt    letterspos alphabet_l_incl        picture
  272.             picture            = SetPenColour    RedColour                        picture
  273.             picture            = DrawStringAt    letterspos alphabet_l_excl        picture
  274.             picture            = SetPenColour    GreenColour                        picture
  275.             picture            = DrawStringAt    (tekstindent,toInt (0.15*h`)) (toString player+++determines_new_word) picture
  276.             picture            = DrawStringAt    (foundpos,toInt (0.60*h`)) found_upto_now picture
  277.             picture            = MovePen        (10,0)                            picture
  278.             picture            = DrawString    placing.word                    picture
  279.             picture            = DrawStringAt    (atpos,toInt (0.75*h`)) at_pos    picture
  280.             picture            = MovePen        (10,0)                            picture
  281.             picture            = DrawString    placingtext                        picture
  282.             picture            = DrawStringAt    (scorepos,toInt (0.90*h`)) score_upto_now picture
  283.             picture            = MovePen        (10,0)                            picture
  284.             picture            = DrawString    (toString placing.score)        picture
  285.         =    picture
  286.         where
  287.             (x,y)            = placing.pos
  288.             thefont            = font 12
  289.             foundlength        = FontStringWidth found_upto_now thefont
  290.             rtabstop        = tekstindent+foundlength
  291.             foundpos        = tekstindent
  292.             atpos            = rtabstop - FontStringWidth at_pos thefont
  293.             scorepos        = rtabstop - FontStringWidth score_upto_now thefont
  294.             
  295.             w`                = toReal w
  296.             h`                = toReal h
  297.             letterspos        = (toInt (0.05*w`),toInt (0.35*h`))
  298.             tekstindent        =  toInt (0.05*w`)
  299.             
  300.             alphabet_l_excl    = if (letter=='a') "" (alphabet%(0,l_index-1))
  301.             alphabet_l_incl    = alphabet%(0,l_index)
  302.             l_index            = toInt letter-a_index
  303.             a_index            = toInt 'a'
  304.             
  305.             placingtext        = toString (x,y)+++" "+++toString placing.dir
  306.         progresslook` player (Finish _) _ size=:(w,h) picture
  307.         #    picture            = SetPenColour    grey            picture
  308.             picture            = FillRectangle    ((0,0),size)    picture
  309.             picture            = SetFont        (font 12)        picture
  310.             picture            = SetPenColour    RedColour        picture
  311.             picture            = DrawStringAt    (toInt (0.05*w`),toInt (0.95*h`)) (toString player+++determined_new_word) picture
  312.         =    picture
  313.         where
  314.             w`                = toReal w
  315.             h`                = toReal h
  316.  
  317. DrawStringAt :: !Point !String !Picture -> Picture
  318. DrawStringAt pos text picture
  319. #    picture    = MovePenTo pos picture
  320.     picture    = DrawString text picture
  321. =    picture
  322.  
  323. DrawVectorAt :: !Point !Vector !Picture -> Picture
  324. DrawVectorAt pos v picture
  325. #    picture    = MovePenTo pos picture
  326.     picture    = LinePen v picture
  327. =    picture
  328.  
  329. drawdisplay :: !Size !Picture -> Picture
  330. drawdisplay size=:(w,h) picture
  331. #    picture    = SetBackColour    BlackColour        picture
  332.     picture    = EraseRectangle ((0,0),size)    picture
  333.     picture    = SetPenColour    grey            picture
  334.     picture    = MovePenTo        (-1,h-1)        picture
  335.     picture    = LinePenTo        (-1,-1)            picture
  336.     picture    = LinePenTo        (w,-1)            picture
  337.     picture    = MovePenTo        (-2,h)            picture
  338.     picture    = LinePenTo        (-2,-2)            picture
  339.     picture    = LinePenTo        (w+1,-2)        picture
  340.     picture    = SetPenColour    WhiteColour        picture
  341.     picture    = MovePenTo        (-1,h)            picture
  342.     picture    = LinePenTo        (w,h)            picture
  343.     picture    = LinePenTo        (w,-2)            picture
  344.     picture    = SetPenColour    rbLighterGrey    picture
  345.     picture    = MovePenTo        (-2,h+1)        picture
  346.     picture    = LinePenTo        (w+1,h+1)        picture
  347.     picture    = LinePenTo        (w+1,-3)        picture
  348. =    picture
  349.